home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / test-call.em < prev    next >
Lisp/Scheme  |  1993-02-02  |  2KB  |  86 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: test-call.em
  4. ;; Date: Tue Jun  2 15:31:28 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule test-call
  11.   (arith 
  12.    lists
  13.    macros0
  14.    list-operators
  15.    streams 
  16.    others
  17.    )
  18.   ()
  19.   
  20.   (defun i (x) x)
  21.  
  22.   (defun a (x) (i x))
  23.  
  24.   (defun b (x) (let ((y (i x))) y))
  25.  
  26.   (defun j (x) (+ x 1))
  27.  
  28.   (defun k (x) (let ((xx (+ x 1))) xx))
  29.  
  30.   (deflocal i1 (lambda (x) x))
  31.  
  32.   (defun a1 (x) (i1 x))
  33.  
  34.   (defun a2 (x) (let ((xx (i1 x))) xx))
  35.  
  36.   (defun acons (x) (cons x x))
  37.  
  38.   (defun bcons (x) (i (cons x x)))
  39.  
  40.   (defun fib (x)
  41.     (if (= x 1) x (* x (fib (- x 1)))))
  42.  
  43.   (defun summit (x y)
  44.     (if (null x) y
  45.       (summit (cdr x) (+ (car x) y))))
  46.  
  47.   ;; mutually recursive, no envs, all tail calls
  48.   (defun ipow (n k)
  49.     (labels ((e0 (x k a)
  50.          (cond ((zerop k) a)
  51.                ((evenp k) 
  52.             (e1 (* x x) (/ k 2) a))
  53.                (t (e0 (* x x) (/ k 2) (* x a)))))
  54.          (e1 (x k a)
  55.          (cond ((evenp k)
  56.             (e1 (* x x) (/ k 2) a))
  57.                (t (e0 (* x x) (/ k 2) (* x a))))))
  58.        (e0 n k 1)))
  59.   
  60.   ;; recursive, env , internal env, tail calling
  61.   (defun messify (x n)
  62.     (labels ((mess-aux (l r)
  63.                (cond ((null l) r)
  64.                  (t (mess-aux (cdr l)
  65.                       (cons (mapcar (lambda (b)
  66.                               (list b (car l) n))
  67.                             (car l))
  68.                         r))))))
  69.         (mess-aux x nil)))
  70.   
  71.   ;;
  72.   (defun rewrite-inline-lambda (lambda-term)
  73.     (labels ((rewrite-args (args values)
  74.                (print (list args values))
  75.                (cond ((null args) nil)
  76.                  ((atom args) 
  77.                   (list (list args (cons 'list values))))
  78.                  (t (cons (list (car args) (car values))
  79.                       (rewrite-args (cdr args) (cdr values)))))))
  80.       (lambda (tran args)
  81.     (print `(let ,(rewrite-args (car lambda-term) args)
  82.           ,@(cdr lambda-term))))))
  83.  
  84.   ;; end module
  85.   )
  86.